perm filename CYCDRB.LSP[3,LMM] blob sn#037471 filedate 1973-04-21 generic text, type T, neo UTF8

(DEFPROP CYCDRBFNS
 (CYCDRBFNS PATMATCH REEDITFACE FACES FACEF1 OTFACE DUPFACE SETEQ EDITFACE FACESIZE FACEMATCH)
VALUE)

(DEFPROP PATMATCH
 (LAMBDA NIL
  (PROG	(X1 X2 Y)
	(SETQ PATSELECT (SETQ FACE NIL))
	(SETQ X1 (REEDITFACE (FACES)))
	(SETQ X2 PATS)
   B	(SETQ CURPAT (CAR X2))
	(SETQ Y (FACEMATCH X1 (PATFACE (CAR X2))))
	(COND ((NULL Y) (GO A)))
	(SETQ Y (NODEPICK1 Y (PATNODFC (CAR X2))))
	(SETQ Y (NODEPICK2 Y))
	(AND Y (RETURN (SETQ PATSELECT (PATPTS Y (PATPOINTS CURPAT)))))
   A	(COND ((SETQ X2 (CDR X2)) (GO B)))
	(RETURN NIL)))
EXPR)

(DEFPROP REEDITFACE
 (LAMBDA(X)
  (PROG	(Y Z Y1 Z1)
	(SETQ Y1 (SETQ Y (CADR X)))
	(SETQ Z1 (SETQ Z (FOR NEW Y IN (CADDR X) LIST (LIST Y))))
	(COND ((NULL Y) (GO A)))
   B	(COND ((NULL (CDR Y)) (GO A)) ((EQ (CAR Y) (CADR Y)) (GO C)))
	(SETQ Y (CDR Y))
	(SETQ Z (CDR Z))
	(GO B)
   C	(RPLACD Y (CDDR Y))
	(RPLACD (CADR Z) (CAR Z))
	(RPLACA Z (CADR Z))
	(RPLACD Z (CDDR Z))
	(GO B)
   A	(RETURN (LIST (CAR X) Y1 Z1))))
EXPR)

(DEFPROP FACES
 (LAMBDA NIL
  (PROG	(X)
	(SETQ FACE NIL)
	(SETQ FACENUM 0.)
	(FOR X := (1. (PLUS NMX -2.)) DO (FACEF1 X X NIL (ADD1 (DIFFERENCE NMX X)) 1.))
	(EDITFACE)
	(RETURN FACE)))
EXPR)

(DEFPROP FACEF1
 (LAMBDA(FST Z LST MXLV LV)
  (PROG	(X Y)
	(SETQ Y (CONN Z))
   A	(COND ((NULL Y) (RETURN NIL)))
	(SETQ X (CAR Y))
	(COND ((EQ X FST) (OTFACE FST LST))
	      ((MEMQ X LST) NIL)
	      ((EQ LV MXLV) NIL)
	      (T (FACEF1 FST X (CONS X LST) MXLV (ADD1 LV))))
	(SETQ Y (CDR Y))
	(GO A)))
EXPR)

(DEFPROP OTFACE
 (LAMBDA(X Y)
  (PROG	NIL
	(COND ((EQ (LENGTH Y) 1.) (RETURN NIL)))
	(SETQ X (CONS X Y))
	(COND ((DUPFACE X) (RETURN NIL)))
	(SETQ FACENUM (ADD1 FACENUM))
	(SETQ FACE (CONS (LIST FACENUM (LENGTH X) X) FACE))
	(RETURN NIL)))
EXPR)

(DEFPROP DUPFACE
 (LAMBDA (X) (FOR NEW Y IN FACE OR (SETEQ X (CADDR Y))))
EXPR)

(DEFPROP SETEQ
 (LAMBDA (X Y) (AND (EQ (LENGTH X) (LENGTH Y)) (EQ (LENGTH X) (LENGTH (UNION X Y)))))
EXPR)

(DEFPROP EDITFACE
 (LAMBDA NIL
  (PROG	(X)
	(SETQ FACE (SORT FACE (FUNCTION (LAMBDA (X Y) (GREATERP (FACESIZE X) (FACESIZE Y))))))
	(SETQ X (MAPCAR (FUNCTION FACESIZE) FACE))
	(RETURN (SETQ FACE (LIST (LENGTH X) X FACE)))))
EXPR)

(DEFPROP FACESIZE
 (LAMBDA (X) (LENGTH (CADDR X)))
EXPR)

(DEFPROP FACEMATCH
 (LAMBDA(F1 F2)
  (PROG	(X1 X2 Y1 Y2 Z)
	(COND ((LESSP (CAR F1) (CAR F2)) (RETURN NIL)))
	(SETQ X1 (CADR F1))
	(SETQ X2 (CADR F2))
	(SETQ Y1 (CADDR F1))
	(SETQ Y2 (CADDR F2))
   A	(COND ((LESSP (CAR X1) (CAR X2)) (RETURN NIL)) ((EQ (CAR X1) (CAR X2)) (GO B)))
	(SETQ Y1 (CDR Y1))
	(COND ((NULL (SETQ X1 (CDR X1))) (RETURN NIL)))
	(GO A)
   B	(SETQ Z (CONS (CONS (CAAR Y2) (CAR Y1)) Z))
	(SETQ Y2 (CDR Y2))
	(COND ((SETQ X2 (CDR X2)) (GO A)))
	(RETURN Z)))
EXPR)